home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_Tix.idb / usr / freeware / lib / tix4.1 / OptMenu.tcl.z / OptMenu.tcl
Encoding:
Text File  |  1999-01-26  |  9.0 KB  |  390 lines
  1. # OptMenu.tcl --
  2. #
  3. #    This file implements the TixOptionMenu widget.
  4. #
  5. # Copyright (c) 1996, Expert Interface Technologies
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10.  
  11.  
  12. tixWidgetClass tixOptionMenu {
  13.     -classname TixOptionMenu
  14.     -superclass tixLabelWidget
  15.     -method {
  16.     add delete disable enable entrycget entryconfigure entries
  17.     }
  18.     -flag {
  19.     -command -disablecallback -dynamicgeometry -value -variable
  20.     -validatecmd -state
  21.     }
  22.     -forcecall {
  23.     -variable -state
  24.     }
  25.     -configspec {
  26.     {-command command Command ""}
  27.     {-disablecallback disableCallback DisableCallback 0 tixVerifyBoolean}
  28.     {-dynamicgeometry dynamicGeometry DynamicGeometry 0 tixVerifyBoolean}
  29.     {-state state State normal}
  30.     {-value value Value ""}
  31.     {-validatecmd validateCmd ValidateCmd ""}
  32.     {-variable variable Variable ""}
  33.     }
  34.     -default {
  35.     {.highlightThickness            0}
  36.     {.takeFocus                0}
  37.     {.frame.menubutton.relief        raised}
  38.     {.frame.menubutton.borderWidth        2}
  39.     {.frame.menubutton.anchor        w}
  40.     {.frame.menubutton.highlightThickness    2}
  41.     {.frame.menubutton.takeFocus        1}
  42.     }
  43. }
  44.  
  45. proc tixOptionMenu:InitWidgetRec {w} {
  46.     upvar #0 $w data
  47.  
  48.     tixChainMethod $w InitWidgetRec
  49.  
  50.     set data(nItems)    0
  51.     set data(items)     ""
  52.     set data(posted)    0
  53.     set data(varInited)    0
  54.     set data(maxWidth)  0
  55. }
  56.  
  57. proc tixOptionMenu:ConstructFramedWidget {w frame} {
  58.     upvar #0 $w data
  59.  
  60.     tixChainMethod $w ConstructFramedWidget $frame
  61.  
  62.     set data(w:menubutton) [menubutton $frame.menubutton -indicatoron 1]
  63.     set data(w:menu)       [menu $frame.menubutton.menu -tearoff 0]
  64.     pack $data(w:menubutton) -side left -expand yes -fill both
  65.  
  66.     $data(w:menubutton) config -menu $data(w:menu)
  67.  
  68.     bind $data(w:menubutton) <Up>   [bind Menubutton <space>]
  69.     bind $data(w:menubutton) <Down> [bind Menubutton <space>]
  70.  
  71.     tixSetMegaWidget $data(w:menubutton) $w
  72. }
  73.  
  74. proc tixOptionMenu:SetBindings {w} {
  75.     upvar #0 $w data
  76.  
  77.     tixChainMethod $w SetBindings
  78. }
  79.  
  80. #----------------------------------------------------------------------
  81. # Private methods
  82. #----------------------------------------------------------------------
  83. proc tixOptionMenu:Invoke {w name} {
  84.     upvar #0 $w data
  85.  
  86.     if {"$data(-state)" == "normal"} {
  87.     tixOptionMenu:SetValue $w $name
  88.     }
  89. }
  90.  
  91. proc tixOptionMenu:SetValue {w value {noUpdate 0}} {
  92.     upvar #0 $w data
  93.  
  94.     if {$data(-validatecmd) != ""} {
  95.     set value [tixEvalCmdBinding $w $data(-validatecmd) "" $value]
  96.     }
  97.  
  98.     set name $value
  99.  
  100.     if {$name == "" || [info exists data(varInited)]} {
  101.     # variable may contain a bogus value
  102.     if {![info exists data($name,index)]} {
  103.         set data(-value) ""
  104.         tixVariable:UpdateVariable $w
  105.         $data(w:menubutton) config -text ""
  106.         return
  107.     }
  108.     }
  109.  
  110.     if [info exists data($name,index)] {
  111.        $data(w:menubutton) config -text $data($name,label)
  112.  
  113.        set data(-value) $value
  114.  
  115.        if {! $noUpdate} {
  116.        tixVariable:UpdateVariable $w
  117.        }
  118.  
  119.        if {$data(-command) != "" && !$data(-disablecallback)} {
  120.        if {![info exists data(varInited)]} {
  121.            set bind(specs) ""
  122.            tixEvalCmdBinding $w $data(-command) bind $value
  123.        }
  124.        }
  125.     } else {
  126.     error "item \"$value\" does not exist"
  127.     }
  128. }
  129.  
  130. proc tixOptionMenu:SetMaxWidth {w} {
  131.     upvar #0 $w data
  132.  
  133.     foreach name $data(items) {
  134.     set len [string length $data($name,label)]
  135.     if {$data(maxWidth) < $len} {
  136.         set data(maxWidth) $len
  137.     }
  138.     }
  139.  
  140.     if {$data(maxWidth) > 0} {
  141.     $data(w:menubutton) config -width $data(maxWidth)
  142.     }
  143. }
  144.  
  145. #----------------------------------------------------------------------
  146. # Configuration
  147. #----------------------------------------------------------------------
  148. proc tixOptionMenu:config-state {w value} {
  149.     upvar #0 $w data
  150.  
  151.     if ![info exists data(w:label)] {
  152.     return
  153.     }
  154.  
  155.     if {$value == "normal"} {
  156.     catch {
  157.         $data(w:label) config -fg \
  158.         [$data(w:menubutton) cget -foreground]
  159.     }
  160.     $data(w:menubutton) config -state $value
  161.     } else {
  162.     catch {
  163.         $data(w:label) config -fg \
  164.         [$data(w:menubutton) cget -disabledforeground]
  165.     }
  166.     $data(w:menubutton) config -state $value
  167.     }
  168. }
  169.  
  170. proc tixOptionMenu:config-value {w value} {
  171.     upvar #0 $w data
  172.  
  173.     tixOptionMenu:SetValue $w $value
  174.  
  175.     # This will tell the Intrinsics: "Please use this value"
  176.     # because "value" might be altered by SetValues
  177.     #
  178.     return $data(-value)
  179. }
  180.  
  181. proc tixOptionMenu:config-variable {w arg} {
  182.     upvar #0 $w data
  183.  
  184.     if [tixVariable:ConfigVariable $w $arg] {
  185.        # The value of data(-value) is changed if tixVariable:ConfigVariable 
  186.        # returns true
  187.        tixOptionMenu:SetValue $w $data(-value) 1
  188.     }
  189.     catch {
  190.     unset data(varInited)
  191.     }
  192.     set data(-variable) $arg
  193. }
  194.  
  195. #----------------------------------------------------------------------
  196. # Public Methdos
  197. #----------------------------------------------------------------------
  198. proc tixOptionMenu:add {w type name args} {
  199.     upvar #0 $w data
  200.  
  201.     if [info exists data($name,index)] {
  202.     error "item $name already exists in the option menu $w"
  203.     }
  204.  
  205.     case $type {
  206.     "command" {
  207.         set validOptions {
  208.         -command -label
  209.         }
  210.         set opt(-command)        ""
  211.         set opt(-label)        $name
  212.  
  213.         tixHandleOptions -nounknown opt $validOptions $args
  214.  
  215.         if {$opt(-command)    != ""} {
  216.         error "option -command cannot be specified"
  217.         }
  218.  
  219.         # Create a new item inside the menu
  220.         #
  221.         eval $data(w:menu) add command $args \
  222.         [list -label $opt(-label) \
  223.         -command "tixOptionMenu:Invoke $w \{$name\}"]
  224.         set index $data(nItems)
  225.  
  226.         # Store info about this item
  227.         #
  228.         set data($index,name) $name
  229.         set data($name,type) cmd
  230.         set data($name,label) $opt(-label)
  231.         set data($name,index) $index
  232.  
  233.         if {$index == 0} {
  234.         $data(w:menubutton) config -text $data($name,label)
  235.         tixOptionMenu:SetValue $w $name
  236.         }
  237.  
  238.         incr data(nItems)
  239.         lappend data(items) $name
  240.  
  241.         if $data(-dynamicgeometry) {
  242.         tixOptionMenu:SetMaxWidth $w
  243.         }
  244.     }
  245.     "separator" {
  246.         $data(w:menu) add separator
  247.  
  248.         set index $data(nItems)
  249.         # Store info about this item
  250.         #
  251.         set data($index,name) $name
  252.         set data($name,type) sep
  253.         set data($name,label) ""
  254.         set data($name,index) $index
  255.  
  256.         incr data(nItems)
  257.         lappend data(items) $name
  258.     }
  259.     default {
  260.         error "only types \"separator\" and \"command\" are allowed"
  261.     }
  262.     }
  263.  
  264.     return ""
  265. }
  266.  
  267. proc tixOptionMenu:delete {w item} {
  268.     upvar #0 $w data
  269.  
  270.     if {![info exists data($item,index)]} {
  271.     error "item $item does not exist in $w"
  272.     }
  273.  
  274.     # Rehash the item list
  275.     set newItems ""
  276.     set oldIndex 0
  277.     set newIndex 0
  278.     foreach name $data(items) {
  279.     if {$item == $name} {
  280.         unset data($name,label)
  281.         unset data($name,index)
  282.         unset data($name,type)
  283.         $data(w:menu) delete $oldIndex
  284.     } else {
  285.         set data($name,index)    $newIndex
  286.         set data($newIndex,name) $name
  287.         incr newIndex
  288.         lappend newItems $name
  289.     }
  290.     incr oldIndex
  291.     }
  292.     incr oldIndex -1; unset data($oldIndex,name)
  293.     set data(nItems) $newIndex
  294.     set data(items) $newItems
  295.  
  296.     if {$data(-value) == $item} {
  297.     set newVal ""
  298.     foreach item $data(items) {
  299.         if {$data($item,type) == "cmd"} {
  300.         set newVal $item
  301.         }
  302.     }
  303.     tixOptionMenu:SetValue $w $newVal
  304.     }
  305.  
  306.     return ""
  307. }
  308.  
  309.  
  310. proc tixOptionMenu:disable {w item} {
  311.     upvar #0 $w data
  312.  
  313.     if {![info exists data($item,index)]} {
  314.     error "item $item does not exist in $w"
  315.     } else {
  316.     catch {$data(w:menu) entryconfig $data($item,index) -state disabled}
  317.     }
  318. }
  319.  
  320. proc tixOptionMenu:enable {w item} {
  321.     upvar #0 $w data
  322.  
  323.     if {![info exists data($item,index)]} {
  324.     error "item $item does not exist in $w"
  325.     } else {
  326.     catch {$data(w:menu) entryconfig $data($item,index) -state normal}
  327.     }
  328. }
  329.  
  330. proc tixOptionMenu:entryconfigure {w item args} {
  331.     upvar #0 $w data
  332.  
  333.     if {![info exists data($item,index)]} {
  334.     error "item $item does not exist in $w"
  335.     } else {
  336.     return [eval $data(w:menu) entryconfig $data($item,index) $args]
  337.     }
  338. }
  339.  
  340. proc tixOptionMenu:entrycget {w item arg} {
  341.     upvar #0 $w data
  342.  
  343.     if {![info exists data($item,index)]} {
  344.     error "item $item does not exist in $w"
  345.     } else {
  346.     return [$data(w:menu) entrycget $data($item,index) $arg]
  347.     }
  348. }
  349.  
  350. proc tixOptionMenu:entries {w} {
  351.     upvar #0 $w data
  352.  
  353.     return $data(items)
  354. }
  355.  
  356.  
  357. proc tixOptionMenu:Destructor {w} {
  358.  
  359.     tixVariable:DeleteVariable $w
  360.  
  361.     # Chain this to the superclass
  362.     #
  363.     tixChainMethod $w Destructor
  364. }
  365.  
  366. #----------------------------------------------------------------------
  367. # Obsolete
  368. # These have been replaced by new commands in Tk 4.0
  369. #
  370. proc tixOptionMenu:Post {w} {
  371.     upvar #0 $w data
  372.  
  373.     set rootx [winfo rootx $data(w:frame)]
  374.     set rooty [winfo rooty $data(w:frame)]
  375.  
  376.     # adjust for the border of the menu and frame
  377.     #
  378.     incr rootx [lindex [$data(w:menu)  config -border] 4]
  379.     incr rooty [lindex [$data(w:frame) config -border] 4]
  380.     incr rooty [lindex [$data(w:menu)  config -border] 4]
  381.  
  382.     set value $data(-value)
  383.     set y [$data(w:menu) yposition $data($value,index)]
  384.  
  385.     $data(w:menu) post $rootx [expr $rooty - $y]
  386.     $data(w:menu) activate $data($value,index)
  387.     grab -global $data(w:menubutton)
  388.     set data(posted) 1
  389. }
  390.